home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Controls / Visual Basic Controls.iso / vbcontrol / axbutton / sortlist.cls < prev    next >
Encoding:
Visual Basic class definition  |  1997-09-15  |  6.3 KB  |  175 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4. END
  5. Attribute VB_Name = "SortedList"
  6. Attribute VB_GlobalNameSpace = False
  7. Attribute VB_Creatable = True
  8. Attribute VB_PredeclaredId = False
  9. Attribute VB_Exposed = False
  10. '-------------------------------------------------------------------------------
  11. ' Copyright ⌐ 1997 Microsoft Corporation. All rights reserved.
  12. '
  13. ' You have a royalty-free right to use, modify, reproduce and distribute the
  14. ' Sample Application Files (and/or any modified version) in any way you find
  15. ' useful, provided that you agree that Microsoft has no warranty, obligations or
  16. ' liability for any Sample Application Files.
  17. '-------------------------------------------------------------------------------
  18.  
  19. '-------------------------------------------------------------------------------
  20. ' This class stores items using sorted keys, for fast retrieval. The preferred
  21. ' retrieval method is by key, but retrieval by index is allowed; the client
  22. ' should realize that an item's index will probably change.
  23. '-------------------------------------------------------------------------------
  24.  
  25. Option Explicit
  26.  
  27. Private Type Item
  28.     Item As Long
  29.     Key As Long
  30. End Type
  31.  
  32. 'The actual data:
  33. Private mudtItems() As Item
  34. Private mcItems As Long
  35.  
  36. Public Property Get Count() As Long
  37.     Count = mcItems
  38. End Property
  39.  
  40. Public Property Get ItemByIndex(Index As Long) As Long
  41.     'Handle the error ourselves if Index is too big. We handle this ourselves
  42.     '   because when the array shrinks, we will not clean up the newly deleted
  43.     '   items. Therefore, an Index greater than Count might still return an
  44.     '   item, but this item would be invalid.
  45.     If Index > mcItems Then Err.Raise 9
  46.     'Let VB handle the error if Index is too small
  47.     ItemByIndex = mudtItems(Index).Item
  48. End Property
  49.  
  50. Public Property Get ItemByKey(Key As Long) As Long
  51.     Dim nIndex As Long
  52.  
  53.     If FindItem(Key, nIndex) Then
  54.         ItemByKey = mudtItems(nIndex).Item
  55.     Else
  56.         Err.Raise 5, , "There is no item with the key " & Key & "."
  57.     End If
  58. End Property
  59.  
  60. Public Property Get KeyByIndex(Index As Long) As Long
  61.     'Handle the error ourselves if Index is too big. We handle this ourselves
  62.     '   because when the array shrinks, we will not clean up the newly deleted
  63.     '   items. Therefore, and Index greater than Count might still return an
  64.     '   item, but this item would be invalid.
  65.     If Index > mcItems Then Err.Raise 9
  66.     'Let VB handle the error  if Index is too small
  67.     KeyByIndex = mudtItems(Index).Key
  68. End Property
  69.  
  70. Public Sub Add(Item As Long, Key As Long)
  71.     Dim nIndex As Long
  72.  
  73.     If FindItem(Key, nIndex) Then
  74.         Err.Raise 457
  75.     Else
  76.         'Add the item at nIndex
  77.         'Grow the array
  78.         mcItems = mcItems + 1
  79.         ReDim Preserve mudtItems(1 To mcItems)
  80.         'Move the items from this position to the former end
  81.         'Only move if there are items to move
  82.         If nIndex < mcItems Then
  83.             'Each item takes up 8 bytes
  84.             CopyMemory mudtItems(nIndex + 1), mudtItems(nIndex), 8 * (mcItems - nIndex)
  85.         End If
  86.         mudtItems(nIndex).Item = Item
  87.         mudtItems(nIndex).Key = Key
  88.     End If
  89. End Sub
  90.  
  91. Public Function Remove(Key As Long) As Long
  92.     Dim nIndex As Long
  93.  
  94.     If FindItem(Key, nIndex) Then
  95.         'Return the item
  96.         Remove = mudtItems(nIndex).Item
  97.         'Move the items from this position + 1 to the end
  98.         'Only move if there are items to move
  99.         If nIndex < mcItems Then
  100.             'Each item takes up 8 bytes
  101.             CopyMemory mudtItems(nIndex), mudtItems(nIndex + 1), 8 * (mcItems - nIndex)
  102.         End If
  103.         'Shrink the array
  104.         mcItems = mcItems - 1
  105.     Else
  106.         Err.Raise 5, , "There is no item with the key " & Key & "."
  107.     End If
  108. End Function
  109.  
  110. Public Sub Clear()
  111.     mcItems = 0
  112.     Erase mudtItems
  113. End Sub
  114.  
  115. 'Given a key, return an index indicating either:
  116. '   1.  The location where the item was found, or
  117. '   2.  The location where the item should be added.
  118. 'Return True to indicate case 1 and False to indicate case 2.
  119. Public Function FindItem(Key As Long, Optional Index As Long) As Boolean
  120.     Dim fFound As Boolean
  121.     Dim nSearchPos As Long
  122.     Dim nLBound As Long
  123.     Dim nUBound As Long
  124.  
  125.     'Perform a binary search on the items
  126.  
  127.     'Start with a field of search which includes all the items
  128.     nUBound = mcItems
  129.     nLBound = 1
  130.  
  131.     'Continue until the field of search is invalid
  132.     Do Until nLBound > nUBound
  133.         'Look at the item in the middle of the field of search
  134.         nSearchPos = (nLBound + nUBound) / 2
  135.         Select Case mudtItems(nSearchPos).Key
  136.             Case Key
  137.                 'We've found it! Stop the loop and remember nSearchPos.
  138.                 fFound = True
  139.                 Exit Do
  140.             Case Is < Key
  141.                 'Narrow the search to the items above nSearchPos
  142.                 nLBound = nSearchPos + 1
  143.             Case Is > Key
  144.                 'Narrow the search to the items below nSearchPos
  145.                 nUBound = nSearchPos - 1
  146.         End Select
  147.     Loop
  148.     If fFound Then
  149.         Index = nSearchPos
  150.         FindItem = True
  151.     Else
  152.         'There are three cases above which would lead to this code:
  153.         '   1.  The loop never ran because mcItems = 0
  154.         '   2.  The loop stopped because Case Is > Key raised nLBound above
  155.         '       nUBound (and above nSearchPos)
  156.         '   3.  The loop stopped because Case Is < Key lowered nUBound below
  157.         '       nLBound
  158.         'In each case, we can determine where the new item should be added
  159.         '   1.  The new item should be added at position 1
  160.         '   2.  The new item should be added at position nLBound
  161.         '   3.  The new item should be added at position nSearchPos
  162.         If nLBound > nSearchPos Then
  163.             'This means that either case 1 or 2 occurred. Therefore the new item
  164.             '   should be added at position 1 or nLBound. In case 1, nLBound = 1
  165.             '   so we can simply use nLBound
  166.             Index = nLBound
  167.         Else
  168.             'This means that case 3 occurred. Therefore the new item should be
  169.             '   added at position nSearchPos.
  170.             Index = nSearchPos
  171.         End If
  172.         'FindItem = False (implicit)
  173.     End If
  174. End Function
  175.